home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
PROGSCAL
/
XGRAPH.LZH
/
SMPLXGRF.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1987-03-22
|
31KB
|
911 lines
program SampleExtendedGraphics;
{
Program to demostrate the use of the XGRAPH routines.
Written by Abe Achkinazi on March 12, 1987.
}
{$I Xgraph.pas}
type
CharPtrType = ^Byte;
MaxString = string[255];
StringPtr = ^StringListType;
StringListType = record
StrPtr : StringPtr;
Line : MaxString;
end;
const
AllBlack:array[0..15] of integer=($00,$00,$00,$00,$00,$00,$00,$00,
$00,$00,$00,$00,$00,$00,$00,$00 );
var { Globals }
GrfData : GraphicsData;
Regs : VidRegs;
Done : boolean;
Input1, Input2, Output1, Output2 : integer;
FontWidth, FontHeight : integer;
Top : StringPtr;
Selection : integer;
c : char;
{ Utility functions }
{ ----------------- }
function GetNum(Strng:VidStringType; var Position, Value:integer):boolean;
{
Given a string and a position in the string, extract the next integer
in the string skipping any characters between the given position and the
number.
}
var first,last : integer;
NumFound : boolean;
Code : integer;
StrCopy : VidStringType;
begin
first := Position;
NumFound := false;
while (first <= Length(Strng)) and not(Strng[first] in ['-', '0'..'9']) do
first := first+1;
if first <= Length(Strng) then begin
NumFound := true; last:=first;
while ((last+1) <= Length(Strng)) and (Strng[last+1] in ['0'..'9']) do
last := last+1;
end;
if NumFound then begin
StrCopy := Copy(Strng,First,(Last-First)+1);
Val(StrCopy,Value,Code);
GetNum := NumFound and (Code = 0); Position := Last+1;
end
else begin GetNum := false; Position := Length(Strng)+1 end;
end; { of GetNum }
procedure AddString(var Top : StringPtr; StringX : MaxString);
{
Adds a string at the end of the chain.
}
var TempStr : StringPtr;
begin
if Top=Nil then begin
new(Top);
Top^.StrPtr:=Nil;
Top^.Line:=StringX
end
else begin
TempStr:=Top;
while TempStr^.StrPtr<>Nil do TempStr:=TempStr^.StrPtr;
new(TempStr^.StrPtr); TempStr:=TempStr^.StrPtr;
TempStr^.StrPtr:=Nil; TempStr^.Line:=StringX;
end;
end; { of AddString }
procedure PaintScreen;
{
Clears graphic screen and draws bounding lines.
}
var LocalRegs: VidRegs;
begin with LocalRegs, GrfData do begin
ax := VidClear shl 8;
Intr(VideoInt, LocalRegs);
ax:=VidLine shl 8 + $78;
cx:=MinX; dx:=Input2+FontHeight; { Top Line }
si:=MaxX; di:=dx;
Intr(VideoInt, LocalRegs);
cx:=si; dx:=di; { Right Line }
si:=si; di:=Output1-1;
Intr(VideoInt, LocalRegs);
cx:=si; dx:=di; { Bottom Line }
si:=MinX; di:=di;
Intr(VideoInt, LocalRegs);
cx:=si; dx:=di; { Left Line }
si:=MinX; di:=Input2+FontHeight;
Intr(VideoInt, LocalRegs);
end end; { of PaintScreen }
procedure ClearInput;
{
Clear command input area.
}
var LocalRegs : VidRegs;
begin with LocalRegs do begin
ax := VidRectFill shl 8 + $0F;
cx := GrfData.MinX; dx:=Input1;
si := GrfData.MaxX; di:=Input2+FontHeight-1;
es:=seg(AllBlack); bx:=ofs(AllBlack);
Intr(VideoInt, LocalRegs);
end end;
Procedure DoChoice( Selections:StringPtr; Que1, Que2:MaxString;
Numbered:boolean; x, y:integer; var Select:integer);
{
Procedure to take a list of choices display them on the screen and
get a selection from the user. The information behind the formed menu
is saved and restored after the user has selected a choice.
}
var
MaxHeight, MaxWidth, RectArea, i: integer;
LineNumber : integer;
TempPtr: StringPtr;
TempStr : MaxString;
IOString: VidStringType;
Code : integer;
SaveAreaLoc : ^byte;
SaveAreaDesc : Raster;
TopOfHeap : ^byte;
LocalBlitParms : BlitParm;
LocalRegs : VidRegs;
Localy : integer;
begin
{ Write queue lines }
ClearInput;
WriteStr(Que1,0,Input1,GrfData); WriteStr(Que2,0,Input2,GrfData);
{ Find Number of strings and widest One }
MaxWidth := 0; MaxHeight:=2; TempPtr:=Selections;
while TempPtr <> Nil do begin
MaxHeight:=MaxHeight+1;
if length(TempPtr^.Line)>MaxWidth then MaxWidth:=length(TempPtr^.Line);
TempPtr := TempPtr^.StrPtr;
end;
MaxWidth:=MaxWidth+2;
if Numbered then MaxWidth:=MaxWidth+4;
{ Save area about to be overwritten by menu }
RectArea := FontHeight*MaxHeight*MaxWidth;
Mark(TopOfHeap);
GetMem(SaveAreaLoc,RectArea);
with SaveAreaDesc do begin
Offset:=ofs(SaveAreaLoc^); Segment:=seg(SaveAreaLoc^);
Width:=MaxWidth;
OrigenX:=0; OrigenY:=0;
CornerX:=FontWidth*MaxWidth-1; CornerY:=FontHeight*MaxHeight-1;
end;
with LocalBlitParms do begin
DestOffset:=ofs(SaveAreaDesc); DestSegment:=seg(SaveAreaDesc);
SrcOffset:=ofs(GrfData); SrcSegment:=seg(GrfData);
RectOrigenX:=0; RectOrigenY:=0;
RectCornerX:=FontWidth*MaxWidth-1; RectCornerY:=FontHeight*MaxHeight-1;
PointX:=x; PointY:=y;
Opcode:=BlitS; TextOp:=TextS;
end;
with LocalRegs do begin
ax:=VidBlit shl 8;
bx:=$010F;
ds:=seg(LocalBlitParms); si:=ofs(LocalBlitParms);
Intr(VideoInt, LocalRegs);
end;
Localy:=y;
{ Do Top Part }
TempStr := '┌';
for i:=1 to MaxWidth-2 do TempStr:=TempStr+'─';
TempStr := TempStr+'┐';
WriteStr(TempStr,x,Localy,GrfData); Localy:=Localy+FontHeight;
{ Do Midle Part }
TempPtr:=Selections; LineNumber := 1;
while TempPtr <> Nil do begin
if Numbered then begin
Str(LineNumber:2,TempStr); LineNumber:=LineNumber+1;
TempStr:='│'+TempStr+') '+TempPtr^.Line;
for i:=1 to MaxWidth-6-length(TempPtr^.Line) do TempStr:=TempStr+' ';
TempStr:=TempStr+'│'
end
else begin
TempStr:='│'+TempPtr^.Line;
for i:=1 to MaxWidth-2-length(TempPtr^.Line) do TempStr:=TempStr+' ';
TempStr:=TempStr+'│'
end;
WriteStr(TempStr,x,Localy,GrfData); Localy:=Localy+FontHeight;
TempPtr:=TempPtr^.StrPtr;
end;
{ Do Bottom Part }
TempStr := '└';
for i:=1 to MaxWidth-2 do TempStr:=TempStr+'─';
TempStr := TempStr+'┘';
WriteStr(TempStr,x,Localy,GrfData); Localy:=Localy+FontHeight;
{ Get selection here }
if Que2 = '' then
ReadStr(IOString,(Length(Que1)+1)*FontWidth,Input1,GrfData)
else
ReadStr(IOString,(Length(Que2)+1)*FontWidth,Input2,GrfData);
Val(IOString,Select,Code);
if Code <> 0 then Select:=-1;
{ Restore area overwritten by menu and return memory }
with LocalBlitParms do begin
DestOffset:=ofs(GrfData); DestSegment:=seg(GrfData);
SrcOffset:=ofs(SaveAreaDesc); SrcSegment:=seg(SaveAreaDesc);
RectOrigenX:=x; RectOrigenY:=y;
RectCornerX:=x+FontWidth*MaxWidth-1; RectCornerY:=y+FontHeight*MaxHeight-1;
PointX:=0; PointY:=0;
Opcode:=BlitS; TextOp:=TextS;
end;
with LocalRegs do begin
ax:=VidBlit shl 8;
bx:=$010F;
ds:=seg(LocalBlitParms); si:=ofs(LocalBlitParms);
Intr(VideoInt, LocalRegs);
end;
Release(TopOfHeap);
end; { of DoChoice }
procedure ClearRegs(var Regs: VidRegs);
begin with Regs do begin
ax:=0; bx:=0; cx:=0; dx:=0; ds:=0; si:=0; es:=0; di:=0
end end;
procedure HexString(i : integer; var HString : VidStringType);
{
Convert a 16-bit integer into a 4 character Hex string.
}
var x, j : integer;
begin
HString:='$';
for j:=1 to 4 do begin
x:=(i shr ((4-j)*4)) and $000F;
case x of
0: HString:=HString+'0'; 1: HString:=HString+'1';
2: HString:=HString+'2'; 3: HString:=HString+'3';
4: HString:=HString+'4'; 5: HString:=HString+'5';
6: HString:=HString+'6'; 7: HString:=HString+'7';
8: HString:=HString+'8'; 9: HString:=HString+'9';
10: HString:=HString+'A'; 11: HString:=HString+'B';
12: HString:=HString+'C'; 13: HString:=HString+'D';
14: HString:=HString+'E'; 15: HString:=HString+'F'
end;
end;
end; { of HexString }
procedure DisplayRegs(Regs : VidRegs);
{
Display the contents of the registers passed in the Output data area.
}
var NumString, IOString : VidStringType;
begin with Regs do begin
HexString(ax, NumString);
IOString:='AX = '+NumString;
HexString(bx, NumString);
IOString:=IOString+' BX = '+NumString;
HexString(cx, NumString);
IOString:=IOString+' CX = '+NumString;
HexString(dx, NumString);
IOString:=IOString+' DX = '+NumString;
WriteStr(IOString, 0,Output1, GrfData);
HexString(ds, NumString);
IOString:='DS = '+NumString;
HexString(si, NumString);
IOString:=IOString+' SI = '+NumString;
HexString(es, NumString);
IOString:=IOString+' ES = '+NumString;
HexString(di, NumString);
IOString:=IOString+' DI = '+NumString;
WriteStr(IOString, 0,Output2, GrfData);
end end;
procedure ClipToScreenPixel(var x,y:integer);
begin
if x < (GrfData.MinX+1) then x:=GrfData.MinX+1;
if x > (GrfData.MaxX-1) then x:=GrfData.MaxX-1;
if y < Input2+FontHeight+1 then y:=Input2+FontHeight+1;
if y > Output1-2 then y:=Output1-2;
end;
procedure ClipToScreenBit(var x,y:integer);
begin
if x < (GrfData.MinimumX+1) then x:=GrfData.MinimumX+1;
if x > (GrfData.MaximumX-1) then x:=GrfData.MaximumX-1;
if y < Input2+FontHeight+1 then y:=Input2+FontHeight+1;
if y > Output1-2 then y:=Output1-2;
end;
procedure SwapPair(var x,y : integer);
var temp : integer;
begin
temp:=y; y:=x; x:=y
end;
procedure GetPattern(var pat : integer);
{
Allow the user to select the filling pattern for the current function.
}
var IOString : VidStringType;
List : StringPtr;
TopOfHeap : ^Byte;
begin
ClearInput; pat:=1;
Mark(TopOfHeap); List:=Nil;
AddString(List,'1/2 Grey'); AddString(List,'2/4 Grey');
AddString(List,'4/8 Grey'); AddString(List,'L/R Diagonals');
AddString(List,'R/L Diagonals'); AddString(List,'Horizontal Lines');
AddString(List,'Vertical Lines'); AddString(List,'Brocade 1');
AddString(List,'Square Weave'); AddString(List,'Brocade 2');
AddString(List,'Crosses and Naughts '); AddString(List,'Triagular Pattern');
AddString(List,'Circular Pattern'); AddString(List,'Braides');
AddString(List,'Fancy Bricks'); AddString(List,'Wizards');
DoChoice(List,'Select an area pattern (1..16): ', '', true,
4,Input2+FontHeight+1, pat);
Release(TopOfHeap); List:=Nil;
pat:=(pat-1) mod 16;
end; { Of GetPattern }
procedure GetPixelCoord(Msg : VidStringType; var x,y : integer;
DefaultX, DefaultY:integer);
{
Get a pixel coordinate from the user and default to given legal value
if wrong data.
}
var IOString : VidStringType; Position :integer;
NumStr : VidStringType;
begin
ClearInput;
WriteStr(Msg, 0,Input1, GrfData);
IOString:='Coordinates must be in the range X in (';
Str(GrfData.MinX+1,NumStr); IOString:=IOString+NumStr+'..';
Str(GrfData.MaxX-1,NumStr); IOString:=IOString+NumStr+'), Y in (';
Str(Input2+FontHeight+1,NumStr); IOString:=IOString+NumStr+'..';
Str(Output1-2,NumStr); IOString:=IOString+NumStr+').';
WriteStr(IOString, 0,Input2, GrfData);
ReadStr(IOString, (Length(Msg)+1)*FontWidth,Input1, GrfData); Position:=1;
if not(GetNum(IOString,Position,x)) then x:=DefaultX;
if not(GetNum(IOString,Position,y)) then y:=DefaultY;
ClipToScreenPixel(x,y);
end; { of GetPixelCoord }
procedure GetBitCoord(Msg : VidStringType; var x,y : integer;
DefaultX, DefaultY:integer);
{
Get a bit coordinate from the user and default to given legal value
if wrong data.
}
var IOString : VidStringType; Position :integer;
NumStr : VidStringType;
begin
ClearInput;
WriteStr(Msg, 0,Input1, GrfData);
IOString:='Coordinates must be in the range X in (';
Str(GrfData.MinimumX+1,NumStr); IOString:=IOString+NumStr+'..';
Str(GrfData.MaximumX-1,NumStr); IOString:=IOString+NumStr+'), Y in (';
Str(Input2+FontHeight+1,NumStr); IOString:=IOString+NumStr+'..';
Str(Output1-2,NumStr); IOString:=IOString+NumStr+').';
WriteStr(IOString, 0,Input2, GrfData);
ReadStr(IOString, (Length(Msg)+1)*FontWidth,Input1, GrfData); Position:=1;
if not(GetNum(IOString,Position,x)) then x:=DefaultX;
if not(GetNum(IOString,Position,y)) then y:=DefaultY;
ClipToScreenBit(x,y);
end; { of GetBitCoord }
procedure GetLinePattern(var LinePat : integer);
{
Get Line pattern from the use.
}
var IOString : VidStringType; Position : integer;
List : StringPtr;
TopOfHeap : ^Byte;
begin
ClearInput; LinePat:=1;
Mark(TopOfHeap); List:=Nil;
AddString(List,'1111111111111111'); AddString(List,'1100110011001100');
AddString(List,'1111000011110000'); AddString(List,'0110011111100110');
AddString(List,'0101010101010101'); AddString(List,'1010101010101010');
AddString(List,'1110111011101110'); AddString(List,'0000000000000000 ');
DoChoice(List,'Select a line pattern (1..8): ', '', true,
4,Input2+FontHeight+1, LinePat);
Release(TopOfHeap); List:=Nil;
LinePat:=(LinePat-1) mod 8;
end; { of GetLinePattern }
{ End of Utility Functions }
{ ------------------------ }
{ Group of procedures corresponding to the different functions in XGRAPH }
{ ---------------------------------------------------------------------- }
procedure DoVidID(var Regs:VidRegs);
{
Returns the current version of the Xgraph routines.
}
var IOString : VidStringType;
Asnwer : integer;
begin
Intr(VideoInt, Regs);
DisplayRegs(Regs);
WriteStr('BH = Major Version Number, BL = Minor Version Number.', 0,Input1,
GrfData);
delay(2000);
end;
procedure DoVidInit(var Regs:VidRegs);
{
Initializes the graphic raster and returns description of it to the user.
Note how the AddString and DoChoice routines can be used to display
temporary data to the user.
}
var IOString, NumString, NumString2 : VidStringType;
Data : GrfDataPtr;
List : StringPtr;
TopOfHeap : ^Byte;
Answer : integer;
begin
Mark(TopOfHeap); List:=Nil;
Intr(VideoInt, Regs);
Data := Ptr(Regs.es, Regs.di);
DisplayRegs(Regs);
HexString(Data^.DestOff,NumString2); HexString(Data^.DestSeg,NumString);
IOString:='Raster Address = '+NumString+':'+NumString2;
AddString(List,IOString);
Str(Data^.RasterWidth:11,NumString);
IOString:='Raster Width = '+NumString;
AddString(List,IOString);
Str(Data^.MinimumX:5,NumString); Str(Data^.MinimumY:5,NumString2);
IOString:='Origen (X,Y) = '+NumString+','+NumString2;
AddString(List,IOString);
Str(Data^.MaximumX:5,NumString); Str(Data^.MaximumY:5,NumString2);
IOString:='End (X,Y) = '+NumString+','+NumString2;
AddString(List,IOString);
HexString(Data^.RowMask,NumString); HexString(Data^.ShiftIntr,NumString2);
IOString:='Mask and Inter = '+NumString+','+NumString2;
AddString(List,IOString);
HexString(Data^.HomeOffset,NumString); HexString(Data^.BankOffset,NumString2);
IOString:='Home and Bank = '+NumString+','+NumString2;
AddString(List,IOString);
Str(Data^.PixelsPByte:11,NumString);
IOString:='Log(P in B) = '+NumString;
AddString(List,IOString);
HexString(Data^.TextureSeg,NumString); HexString(Data^.TextureOff,NumString2);
IOString:='Textures Addrs = '+NumString+':'+NumString2;
AddString(List,IOString);
HexString(Data^.FontFormSeg,NumString);
HexString(Data^.FontFormOff,NumString2);
IOString:='Font1 Address = '+NumString+':'+NumString2;
AddString(List,IOString);
HexString(Data^.Font2FormSeg,NumString);
HexString(Data^.Font2FormOff,NumString2);
IOString:='Font2 Address = '+NumString+':'+NumString2;
AddString(List,IOString);
DoChoice(List,'The ES:DI register pair points to the data below.',
'Hit Enter to continue ...', false, 4, Input2+FontHeight+1,
Answer);
Release(TopOfHeap); List:=Nil;
end;
procedure DoVidClear(var Regs:VidRegs);
{
Clears the current graphic raster to black independant of video mode.
}
var IOString : VidStringType;
Asnwer : integer;
begin
Intr(VideoInt, Regs);
PaintScreen;
DisplayRegs(Regs);
WriteStr('The Screen is cleared.', 0,Input1, GrfData);
delay(2000);
end;
procedure DoVidRectFill(var Regs:VidRegs);
{
Do VidRecFill of the area specified using the given pattern.
}
var Answer : integer;
begin
Regs.ax:=Regs.ax or $000F;
DisplayRegs(Regs);
GetPattern(Answer);
Regs.es := GrfData.TextureSeg;
Regs.bx := GrfData.TextureOff+Answer*32;
DisplayRegs(Regs);
GetPixelCoord('Enter pixel coordinates of upper left corner (x,y): ',
Regs.cx,Regs.dx, 200 div GrfData.BitPixelDensity,50);
DisplayRegs(Regs);
GetPixelCoord('Enter pixel coordinates of bottom right corner (x,y): ',
Regs.si, Regs.di, 300 div GrfData.BitPixelDensity,150);
{ If rectangle points in wrong order re-order them }
if Regs.cx > Regs.si then SwapPair(Regs.cx,Regs.si);
if Regs.dx > Regs.di then SwapPair(Regs.dx,Regs.di);
DisplayRegs(Regs);
Intr(VideoInt, Regs);
end;
procedure DoVidLine(var Regs:VidRegs);
{
Do VidLine functions after getting user parameter: Line coordinates and
line pattern.
}
var IOString : VidStringType;
Position : integer;
Answer : integer;
begin
Regs.ax:=Regs.ax or $0078;
DisplayRegs(Regs);
WriteStr('Do you want to ''Xor'' or ''Plot'' the line to the screen (X/P) ?',
0,Input1, GrfData);
ReadStr(IOString, 63*FontWidth,Input1, GrfData);
if (IOString='X') or (IOString='x') then begin
Regs.ax:=Regs.ax or $0080;
DisplayRegs(Regs);
end;
GetLinePattern(Answer);
Regs.ax:=Regs.ax or Answer;
DisplayRegs(Regs);
GetPixelCoord('Enter pixel coordinates of one endpoint (x,y): ',
Regs.cx,Regs.dx, 325 div GrfData.BitPixelDensity,100);
DisplayRegs(Regs);
GetPixelCoord('Enter pixel coordinates of other endpoint (x,y): ',
Regs.si,Regs.di, 425 div GrfData.BitPixelDensity,100);
DisplayRegs(Regs);
Intr(VideoInt, Regs);
end;
procedure DoVidPolyFill(var Regs:VidRegs);
{
Do VidPolyFill function after getting parameters (Polygon type, line type
fill type, vertices. Defaults to a diamond pattern of 10 vertices.
}
const
DefaultVertices : array[0..19] of integer = (
475, 75, 475,125, 525,125, 525, 75, 475, 75,
450,100, 500,150, 550,100, 500, 50, 500, 50 );
var IOString : VidStringType; Position : integer;
Answer, PolyType : integer;
List : StringPtr;
TopOfHeap : ^Byte;
Vertices : array[0..20] of integer;
MaxVertex : integer;
Vertex : integer;
begin
ClearInput;
Mark(TopOfHeap); List:=Nil;
AddString(List,'Polygon Border Only, ');
AddString(List,'Polygon and Border,'); AddString(List,'Polygon Only.');
DoChoice(List,'Select Polygon type (1..3): ', '', true,
4,Input2+FontHeight+1, PolyType);
Release(TopOfHeap); List:=Nil;
PolyType:=(PolyType-1) mod 3;
Regs.ax:=Regs.ax or $0078; Regs.cx:=Regs.cx or $000F;
case PolyType of
0 : begin { Polygon Border Only }
GetLinePattern(Answer);
Regs.ax:=Regs.ax or Answer;
end;
1 : begin { Polygon and Border }
Regs.cx:=Regs.cx or $0100;
GetLinePattern(Answer);
Regs.ax:=Regs.ax or Answer;
GetPattern(Answer);
Regs.es := GrfData.TextureSeg;
Regs.bx := GrfData.TextureOff+Answer*32;
end;
2 : begin { Polygon Only }
Regs.cx:=Regs.cx or $0500;
GetPattern(Answer);
Regs.es := GrfData.TextureSeg;
Regs.bx := GrfData.TextureOff+Answer*32;
end
end;
DisplayRegs(Regs);
ClearInput;
IOString:='Number of Vertices (3..10):';
WriteStr(IOString, 0,Input1, GrfData);
ReadStr(IOString, (Length(IOString)+1)*FontWidth,Input1, GrfData);
Position:=1;
if not(GetNum(IOString, Position, MaxVertex)) then MaxVertex:=10;
if (MaxVertex<3) or (MaxVertex>10) then MaxVertex:=10;
Vertices[0]:=MaxVertex;
for Vertex:=1 to MaxVertex do begin
Str(Vertex, IOString);
IOString:='Enter vertex #'+IOString+', (x,y):';
GetPixelCoord(IOString, Vertices[Vertex*2-1],Vertices[Vertex*2],
DefaultVertices[Vertex*2-2] div GrfData.BitPixelDensity,
DefaultVertices[Vertex*2-1]);
end;
Regs.ds:=seg(Vertices); Regs.si:=ofs(Vertices);
Intr(VideoInt, Regs);
DisplayRegs(Regs);
end;
procedure DoVidBlit(var Regs:VidRegs);
{
Do a simplified blit function. Only allows to blit areas on the display and
in EGA's case always uses all bit-planes (i.e no color). This is a
limitation of SMPLXGRF not of the Blit function!. It defaults to bliting
the VidRectFill rectangle over to the VidPolyFill area.
}
var IOString : VidStringType; Position : integer;
Answer : integer;
List : StringPtr;
TopOfHeap : ^Byte;
BlitParms : BlitParm;
begin
ClearInput;
Regs.bx := $010F;
Regs.ds := seg(BlitParms); Regs.si:=ofs(BlitParms);
DisplayRegs(Regs);
with BlitParms, GrfData do begin
DestOffset:=ofs(GrfData); DestSegment:=seg(GrfData);
SrcOffset:=ofs(GrfData); SrcSegment:=seg(GrfData);
TextSegment:=TextureSeg; TextOffset:=TextureOff;
end;
Mark(TopOfHeap); List:=Nil;
AddString(List,'0,'); AddString(List,'Src and Dst,');
AddString(List,'Src and Not(Dst),'); AddString(List,'Src,');
AddString(List,'Not(Src) and Dst,'); AddString(List,'Dst,');
AddString(List,'Src xor Dst,'); AddString(List,'Src or Dst,');
AddString(List,'Not(Src) and Not(Dst),'); AddString(List,'Not(Src) xor Dst,');
AddString(List,'Not(Dst),'); AddString(List,'Src or Not(Dst),');
AddString(List,'Not(Src),'); AddString(List,'Not(Src) or Dst,');
AddString(List,'Not(Src) or Not(Dst),'); AddString(List,'1,');
Answer:=BlitS;
DoChoice(List,'Select Blit operation (1..16): ', '', true,
4,Input2+FontHeight+1, Answer);
Release(TopOfHeap); List:=Nil;
Answer:=(Answer-1) mod 16;
BlitParms.Opcode:=Answer;
if BlitParms.Opcode in { Needs source }
[BlitSandD, BlitSandND, BlitS, BlitNSandD, BlitSxorD, BlitSorD,
BlitNSandND, BlitNSxorD, BlitSorND, BlitNS, BlitNSorD, BlitNSorND]
then begin
Mark(TopOfHeap); List:=Nil;
AddString(List,'0,'); AddString(List,'1,');
AddString(List,'Src,'); AddString(List,'Pat,');
AddString(List,'Src or Pat,'); AddString(List,'Src and Pat,');
AddString(List,'Src xor Pat,'); AddString(List,'Not(Pat),');
AddString(List,'Src or Not(Pat),'); AddString(List,'Src and Not(Pat),');
AddString(List,'Src xor Not(Pat). ');
Answer:=TextS;
DoChoice(List,'Select source texturing operation (1..11): ', '', true,
4,Input2+FontHeight+1, Answer);
Release(TopOfHeap); List:=Nil; Mark(TopOfHeap);
Answer:=(Answer-1) mod 11;
BlitParms.TextOp:=Answer;
if BlitParms.TextOp in
[TextP, TextSorP, TextSandP, TextSxorP, TextNP, TextSorNP,
TextSandNP, TextSxorNP] then begin
GetPattern(Answer);
BlitParms.TextOffset := BlitParms.TextOffset+Answer*32;
end;
end
else BlitParms.TextOP:=Text0;
GetBitCoord('Enter bit coord of Destination''s upper left corner (x,y): ',
BlitParms.RectOrigenX,BlitParms.RectOrigenY, 450,50);
GetBitCoord('Enter bit coord of Destination''s bottom right corner (x,y): ',
BlitParms.RectCornerX, BlitParms.RectCornerY, 550,150);
if BlitParms.RectOrigenX > BlitParms.RectCornerX then
SwapPair(BlitParms.RectOrigenX,BlitParms.RectCornerX);
if BlitParms.RectOrigenY > BlitParms.RectCornerY then
SwapPair(BlitParms.RectOrigenY,BlitParms.RectCornerY);
if BlitParms.Opcode in { Needs source }
[BlitSandD, BlitSandND, BlitS, BlitNSandD, BlitSxorD, BlitSorD,
BlitNSandND, BlitNSxorD, BlitSorND, BlitNS, BlitNSorD, BlitNSorND] then
GetBitCoord('Enter bit coord of Source''s origen (x,y): ',
BlitParms.PointX,BlitParms.PointY, 200,50)
else begin
BlitParms.PointX := BlitParms.RectOrigenX;
BlitParms.PointY := BlitParms.RectOrigenY;
end;
Intr(VideoInt, Regs);
DisplayRegs(Regs);
end;
{ End of XGRAPH procedures }
{ ------------------------ }
{ Utility functions directly accessible by the user: }
{ -------------------------------------------------- }
procedure DoVidSetMode(var Regs : VidRegs);
{
Allows the user to select a new video mode. This allows to test the
XGRAPH routines in all graphic raster configurations that the adapter
can support.
}
var IOString : VidStringType;
Mode, code : integer;
begin
ClearInput;
IOString:='Enter new video mode: ';
WriteStr(IOString, 0,Input1, GrfData);
ReadStr(IOString, (Length(IOString)+1)*FontWidth,Input1, GrfData);
Val(IOString,Mode,Code);
if Code<>0 then Mode:=-1
else Regs.ax:=Regs.ax+Mode;
GraphInit(GrfData,Mode);
if GrfData.CurrFont = 1 then begin
Input1:=0; Input2:=8;
Output1:=GrfData.MaximumY-16; Output2:=GrfData.MaximumY-8;
FontHeight:=8; FontWidth:=8;
end
else begin
Input1:=0; Input2:=14;
Output1:=GrfData.MaximumY-28; Output2:=GrfData.MaximumY-14;
FontHeight:=14; FontWidth:=8;
end;
PaintScreen;
DisplayRegs(Regs);
end;
procedure DumpGraphics;
{
Simple procedure to dump the current graphic screen to an Epson/IBM
compatible printer. Warning only tested on an Epson EX-800 printer.
}
var
CharPtr : CharPtrType;
PrnRaster : Raster;
LocalBlitParms : BlitParm;
LocalRegs : VidRegs;
TopOfHeap : ^byte;
i : integer;
procedure DumpColumn(Number:integer; CharPtr : CharPtrType);
var i : integer;
begin
Number:=Number+100;
write(Lst,chr(27),'K',chr(Number mod 256),chr(Number div 256));
for i:=1 to 100 do write(Lst,chr(0));
for i:=101 to Number do begin
write(Lst,chr(CharPtr^));
CharPtr := Ptr(Seg(CharPtr^),Ofs(CharPtr^)-1);
end;
writeln(Lst);
end;
begin
Mark(TopOfHeap);
GetMem(CharPtr, GrfData.MaximumY-GrfData.MinimumY+1);
with PrnRaster do begin
Offset:=Ofs(CharPtr^); Segment:=Seg(CharPtr^);
Width:=1; OrigenX:=0; OrigenY:=0;
CornerX:=7; CornerY:=GrfData.MaximumY-GrfData.MinimumY
end;
CharPtr:=Ptr(Seg(CharPtr^),Ofs(CharPtr^)+GrfData.MaximumY-GrfData.MinimumY);
with LocalBlitParms do begin
DestOffset:=Ofs(PrnRaster); DestSegment:=Seg(PrnRaster);
SrcOffset:=Ofs(GrfData); SrcSegment:=Seg(GrfData);
RectOrigenX:=0; RectOrigenY:=0;
RectCornerX:=7; RectCornerY:=PrnRaster.CornerY;
PointX:=0; PointY:=0;
Opcode:=BlitS; TextOp:=TextS;
end;
with LocalRegs do begin
ax:=VidBlit shl 8; bx:=$010F;
ds:=Seg(LocalBlitParms); si:=Ofs(LocalBlitParms);
end;
writeln(Lst,chr(27),'A',chr(8),chr(27),'2');
for i:=1 to (GrfData.MaximumX-GrfData.MinimumX+1) div 8 do begin
Intr(VideoInt, LocalRegs);
DumpColumn(GrfData.MaximumY-GrfData.MinimumY+1,CharPtr);
LocalBlitParms.PointX:=LocalBlitParms.PointX+8;
end;
writeln(Lst,chr(27),'@');
write(Lst,chr(12));
release(TopOfHeap);
end; { of DumpGraphics }
{ End of utilities accessible to the user. }
{ ---------------------------------------- }
procedure GetFunction( var Regs : VidRegs; var Done : Boolean);
{
Procedure to get an XGRAPH function and its parameters or a utility
function from the user. This is the "main" loop of the program.
}
var FunctionsStr : StringPtr;
TopOfHeap : ^byte;
Answer : integer;
begin
Done := false;
Mark(TopOfHeap);
FunctionsStr:=Nil;
AddString(FunctionsStr,'VidID,');
AddString(FunctionsStr,'VidInit,'); AddString(FunctionsStr,'VidClear,');
AddString(FunctionsStr,'VidRectFill, '); AddString(FunctionsStr,'VidLine,');
AddString(FunctionsStr,'VidPolyFill,'); AddString(FunctionsStr,'VidBlit,');
AddString(FunctionsStr,'Change Mode,'); AddString(FunctionsStr,'PrintScr,');
AddString(FunctionsStr,'Or Quit.');
repeat
DoChoice(FunctionsStr,'Select video function number or Quit:', '', true,
4,Input2+FontHeight+1, Answer);
until (Answer>0) and (Answer<11);
Release(TopOfHeap); FunctionsStr:=Nil;
ClearRegs(Regs);
Regs.ax:=(Answer+$A2) shl 8;
case Answer of
1 : DoVidId(Regs);
2 : DoVidInit(Regs);
3 : DoVidClear(Regs);
4 : DoVidRectFill(Regs);
5 : DoVidLine(Regs);
6 : DoVidPolyFill(Regs);
7 : DoVidBlit(Regs);
8 : begin Regs.ax := VidSetMode shl 8; DoVidSetMode(Regs) end;
9 : DumpGraphics;
10 : Done:=true
end;
end; { of GetFunctions }
begin { of main }
{ Find XGRAPH routines }
with Regs do begin
ax:=VidId shl 8; bx:=$FFFF;
Intr(VideoInt, Regs);
end;
if Regs.bx <> $FFFF then begin
GraphInit(GrfData,-1);
if GrfData.VideoMode <> -1 then begin { Adapter can do graphics }
if GrfData.CurrFont = 1 then begin { 200 lines graphics }
Input1:=0; Input2:=8;
Output1:=GrfData.MaximumY-16; Output2:=GrfData.MaximumY-8;
FontHeight:=8; FontWidth:=8;
end
else begin { > 200 lines graphics }
Input1:=0; Input2:=14;
Output1:=GrfData.MaximumY-28; Output2:=GrfData.MaximumY-14;
FontHeight:=14; FontWidth:=8;
end;
PaintScreen;
WriteStr('SmplXgrf: A Simple Xgraph.exe user interface',
0,Input1,GrfData);
WriteStr('written by Abe Achkinazi on March 11, 1987.',
0,Input2,GrfData);
Delay(2000);
repeat
ClearInput;
WriteStr('Hit a key to activate function menu.', 0,Input1, GrfData);
repeat until KeyPressed;
read(kbd,c);
GetFunction(Regs, Done);
until Done;
TextMode;
end
else begin { No graphic modes }
writeln('Current video configuration does not allow graphics.');
writeln('Must have a CGA or EGA type adapter as the primary display.');
end;
end
else writeln('XGRAPH routines not found. Install then running XGRAPH.EXE.');
end.